home *** CD-ROM | disk | FTP | other *** search
/ Delphi Developer's Kit 1996 / Delphi Developer's Kit 1996.iso / power / acc_obj0 / u_egd_0a.pas < prev   
Encoding:
Pascal/Delphi Source File  |  1995-12-22  |  12.4 KB  |  361 lines
  1. UNIT U_EGD_0a;                          {Last mod by JFH on 07/20/95}
  2.  
  3. { DEFINES EXAMPLE READER AND ACCESS CLASSES FOR AutoCADD DXF FILES }
  4.  
  5. { Pgm. 07/20/95 by John F Herbster for CIS Delphi Object Pascal Lib. }
  6.  
  7. {=====} INTERFACE {====================================================}
  8.  
  9. {-----} USES {-----}
  10.   U_EGB_0a,
  11.   SysUtils;
  12.  
  13. {----- The File Image of Binary DXF data ------------------------------}
  14.  
  15. CONST {For defining the binary record structure.}
  16.   dtUnk = 0; dtInt = 1; dtLong = 2; dtDbl = 3; dtZStr = 4;
  17.              dtExt = 5{Marker for extended code};
  18.              deInt = 6; deLong = 7; deDbl = 8; deZStr = 9;
  19.              deSBB = 10  {Small Binary Blocks};
  20.              deByte = 11;
  21.  
  22. { The following record is the image of the datum as used in the binary
  23.   version of the DXF files.  This image may be tracked along in the
  24.   binary buffers and/or pulled out and packed together in byte arrays.}
  25.  
  26. TYPE
  27.   zString = array [1..256] of char;
  28.   pDxfBinaryDatum = ^tDxfBinaryDatum;
  29.   tDxfBinaryDatum = record {This is the varient record itself.}
  30.     Case SCode: byte of {Array DxfGFmt translates SCode into "dt" #s.}
  31.       dtInt:  (bInt:  integer{for integers});
  32.       dtLong: (bLong: longint{for codes 90..99});
  33.       dtDbl:  (bDbl:  double {for floating point});
  34.       dtZStr: (bZStr: zString{for character data});
  35.       dtExt:  (Case ECode: integer of {DxfXFmt cvts GExt into "de" #s.}
  36.         deInt:  (cInt:  integer{for integers});
  37.         deLong: (cLong: longint{for 32-bit ints});
  38.         deDbl:  (cDbl:  double {for floating point});
  39.         deZStr: (cZStr: zString{for character data});
  40.         deSBB:  (cStr:  string {for small binary objects});
  41.         deByte: (cByte: byte));
  42.     end;
  43.  
  44. {----- Functions for creating the binary records -----}
  45.  
  46. Procedure MkBDxfIntRec
  47.     (const Code: integer; const Value: longint;
  48.      var Rec:  tDxfBinaryDatum; var Lgh: word);
  49.  
  50. Procedure MkBDxfDblRec
  51.     (const Code: integer; const Value: extended;
  52.      var Rec:  tDxfBinaryDatum; var Lgh: word);
  53.  
  54. Procedure MkBDxfStrRec
  55.     (Const Code: integer; const Value: string;
  56.      var Rec:  tDxfBinaryDatum; var Lgh: word);
  57.  
  58. {----- Functions for interpreting binary DXF records -----}
  59.  
  60. Procedure GetCodeAndLgh
  61.     (pRec: pDxfBinaryDatum; var Code: integer; var Lgh: word);
  62.  
  63. {----- tBinaryDxfScanner Class object -----}
  64.  
  65. TYPE
  66.   tBinaryDxfScanner = class (tBufferedFileScanner)
  67.     Constructor Create
  68.         (const Pathname: string; aClusterSize: word);
  69.   { opens the file. }
  70.     Function LocNextDxfRec
  71.        (var pRec: pDxfBinaryDatum; var GroupCode: integer): boolean;
  72.     end;
  73.  
  74. TYPE
  75.   tBufferedFileWriter = class
  76.     Constructor Create
  77.         (const Pathname: string; aClusterSize: word);
  78.     { creates a new file and opens it, overwriting any previous. }
  79.     Procedure WriteRec (var Rec; NbrBytes: word);
  80.     { writes the NbrBytes starting at Rec to the buffer.  When the
  81.       buffer is full it is copied to disk. }
  82.     Destructor Distroy;
  83.     { copies the stuff, if any, in the buffer out to the file,
  84.       closes the file, and returns the buffer memory to system. }
  85.     protected
  86.     Chan: file;
  87.     pBuf: pByteArray;
  88.     SizeOfBuf: word;
  89.     oi: word; {index of next available spot in buffer.}
  90.     Procedure FlushToDisk;
  91.     end;
  92.  
  93.  
  94. {=====} implementation {===============================================}
  95.  
  96. Function zStrLgh (const zs: zString): word;
  97.  Var i: word;
  98.  Begin
  99.   i:=0; While (i<255) and (zs[i+1]<>#0) do inc(i);
  100.   Result:=i;
  101.   End;
  102.  
  103. { Array DxfGFmt(g) will convert the 0..255 group code into a case code
  104.   designating the kind of storage.}
  105. CONST
  106.   DxfGFmt: array [byte] of byte =
  107.       {000}(4,4,4,4,4, 4,4,4,4,4,  3,3,3,3,3, 3,3,3,3,3, {4=zStr}
  108.       {020} 3,3,3,3,3, 3,3,3,3,3,  3,3,3,3,3, 3,3,3,3,3, {3=Dbl}
  109.       {040} 3,3,3,3,3, 3,3,3,3,3,  3,3,3,3,3, 3,3,3,3,3,
  110.       {060} 1,1,1,1,1, 1,1,1,1,1,  1,1,1,1,1, 1,1,1,1,1, {1=Int}
  111.       {080} 0,0,0,0,0, 0,0,0,0,0,  2,2,2,2,2, 2,2,2,2,2, {2=Long}
  112.       {100} 4,0,4,0,0, 4,0,0,0,0,  0,0,0,0,0, 0,0,0,0,0, {0=Unk}
  113.       {120} 0,0,0,0,0, 0,0,0,0,0,  0,0,0,0,0, 0,0,0,0,0,
  114.       {140} 3,3,3,3,3, 3,3,3,0,0,  0,0,0,0,0, 0,0,0,0,0,
  115.       {160} 0,0,0,0,0, 0,0,0,0,0,  1,1,1,1,1, 1,0,0,0,0,
  116.       {180} 0,0,0,0,0, 0,0,0,0,0,  0,0,0,0,0, 0,0,0,0,0,
  117.       {200} 0,0,0,0,0, 0,0,0,0,0,  3,0,0,0,0, 0,0,0,0,0,
  118.       {220} 3,0,0,0,0, 0,0,0,0,0,  3,0,0,0,0, 0,0,0,0,0,
  119.       {240} 0,0,0,0,0, 0,0,0,0,0,  0,0,0,0,0, dtExt);
  120.   NbrXFmt = 9;  {Number of extended ranges}
  121.   DxfXFmt: array [0..NbrXFmt-1] of record R1,R2: integer; DE: word end =
  122.   { This array defines the extra ranges (R1..R2) of data types.}
  123.      ((R1: 280;R2: 289;DE:deByte), {Byte value}
  124.       (R1: 300;R2: 309;DE:deZStr), {Arb. text}
  125.       (R1: 310;R2: 319;DE:deZStr), {Hex handle}
  126.       (R1: 320;R2: 369;DE:deZStr), {Hex handle}
  127.       (R1: 999;R2: 999;DE:deZStr), {Comment}
  128.       (R1:1000;R2:1009;DE:deDbl),
  129.       (R1:1010;R2:1059;DE:deDbl),
  130.       (R1:1060;R2:1069;DE:deInt),
  131.       (R1:1071;R2:1071;DE:deLong));
  132.  
  133. Procedure GetCodeAndLgh
  134.     (pRec: pDxfBinaryDatum; var Code: integer; var Lgh: word);
  135.  Var i: integer;
  136.  Begin
  137.   If pRec=nil then begin Code:=-$800; Lgh:=0; EXIT end;
  138.   With pRec^ do begin
  139.     Code:=SCode;
  140.     Case DxfGFmt[Code] of
  141.       dtInt:  Lgh:=SizeOf(integer)+1;
  142.       dtLong: Lgh:=SizeOf(longint)+1; {R13DXF.HLP didn't incl.}
  143.       dtDbl:  Lgh:=SizeOf(double)+1{BCode};
  144.       dtZStr: Lgh:=zStrLgh(bZStr)+1{BCose}+1{term};
  145.       dtExt:  begin
  146.         i:=0; Code:=ECode;
  147.         While i<NbrXFmt do with DxfXFmt[i] do begin
  148.           If (R1<=Code) and (Code<=R2)
  149.             then begin
  150.               Case DE {the data storage code} of
  151.                 deInt:  Lgh:=SizeOf(integer)+3;
  152.                 deLong: Lgh:=SizeOf(longint)+3;
  153.                 deDbl:  Lgh:=SizeOf(double)+3;
  154.                 deZStr: Lgh:=zStrLgh(cZStr)+1+4;
  155.                 deSBB:  Lgh:=length(cStr)+1+4; {Small Binary Blocks}
  156.                 deByte: Lgh:=1+2+1;
  157.                 else    Lgh:=0;
  158.                 end;
  159.               i:=MaxInt;
  160.               end
  161.             else inc(i);
  162.           end{While};
  163.         If i=NbrXFmt then Lgh:=0;
  164.         end{case};
  165.       else {Unknown} Lgh:=0;
  166.       end;
  167.     end;
  168.   End;
  169.  
  170. {----- Functions for creating the binary records -----}
  171.  
  172. Procedure MkBDxfIntRec
  173.     (const Code: integer; const Value: longint;
  174.      var Rec:  tDxfBinaryDatum; var Lgh: word);
  175.   Var stype: word; s: string; b: byte; i: integer;
  176.   Begin With Rec do Begin
  177.     FillChar(Rec,SizeOf(Rec),0);  {Just for debugging!!}
  178.     If (Code>=0) and (Code<=255)
  179.       then {short} begin
  180.         SCode:=Code;
  181.         Case DxfGFmt[Code] of
  182.           dtInt:  begin bInt :=Value; Lgh:=SizeOf(bInt)+1; end;
  183.           dtLong: begin bLong:=Value; Lgh:=SizeOf(bLong)+1 end;
  184.           dtDbl:  begin bDbl :=Value; Lgh:=SizeOf(bDbl)+1 end;
  185.           dtZStr: begin
  186.             Str(Value:0,s);
  187.             For b:=1 to length(s) do bzStr[b]:=s[b];
  188.             bzStr[length(s)+1]:=#0;
  189.             Lgh:=length(s)+1+1 end;
  190.           else begin Lgh:=0 end;
  191.           end{cases};
  192.         end{short}
  193.       else {extended} begin
  194.         SCode:=255; ECode:=Code; i:=0;
  195.         While i<NbrXFmt do with DxfXFmt[i] do begin
  196.           If (R1<=Code) and (Code<=R2)
  197.             then begin
  198.               Case DE {the data storage code} of
  199.                 deInt:  begin cInt :=Value; Lgh:=SizeOf(cInt)+3 end;
  200.                 deLong: begin cLong:=Value; Lgh:=SizeOf(cLong)+3 end;
  201.                 deDbl:  begin cDbl :=Value; Lgh:=SizeOf(double)+3 end;
  202.                 deByte: begin cByte:=Value; Lgh:=1+2+1 end;
  203.                 else    Lgh:=0;
  204.                 end;
  205.               i:=MaxInt;
  206.               end{did it}
  207.             else inc(i);
  208.           end{While};
  209.         end{extended};
  210.   End{With}; End;
  211.  
  212. Procedure MkBDxfDblRec
  213.     (const Code: integer; const Value: extended;
  214.      var Rec:  tDxfBinaryDatum; var Lgh: word);
  215.   Begin
  216.   Lgh:=0;  {Define the real thing later.}
  217.   End;
  218.  
  219. Procedure MkBDxfStrRec
  220.     (Const Code: integer; const Value: string;
  221.      var Rec:  tDxfBinaryDatum; var Lgh: word);
  222.   Var b: byte; i,ec: integer; li: longint; d: double;
  223.   Begin With Rec do Begin
  224.     FillChar(Rec,SizeOf(Rec),0);  {Just for debugging!!}
  225.     If (Code>=0) and (Code<=255)
  226.       then {short} begin
  227.         SCode:=Code;
  228.         Case DxfGFmt[Code] of
  229.           dtInt:  begin
  230.             Val(Value,li,ec);
  231.             If (ec=0) and (li>=-$8000) and (li<$8000)
  232.               then begin bInt:=li; Lgh:=SizeOf(bInt)+1 end
  233.               else Lgh:=0;
  234.             end;
  235.           dtLong: begin
  236.             Val(Value,li,ec);
  237.             If (ec=0)
  238.               then begin bLong:=li; Lgh:=SizeOf(bLong)+1 end
  239.               else Lgh:=0;
  240.             end;
  241.           dtDbl:  begin
  242.             Val(Value,d,ec);
  243.             If (ec=0)
  244.               then begin bDbl:=d; Lgh:=SizeOf(bDbl)+1 end
  245.               else Lgh:=0;
  246.             end;
  247.           dtZStr: begin
  248.             For b:=1 to length(Value) do bzStr[b]:=Value[b];
  249.             bzStr[length(Value)+1]:=#0;
  250.             Lgh:=length(Value)+1+1 end;
  251.           else begin Lgh:=0 end;
  252.           end{cases};
  253.         end{short}
  254.       else {extended} begin
  255.         SCode:=255; ECode:=Code; i:=0;
  256.         While i<NbrXFmt do with DxfXFmt[i] do begin
  257.           If (R1<=Code) and (Code<=R2)
  258.             then begin
  259.               Case DE {the data storage code} of
  260.                 deInt:  begin
  261.                   Val(Value,li,ec);
  262.                   If (ec=0) and (li>=-$8000) and (li<$8000)
  263.                     then begin cInt:=li; Lgh:=SizeOf(cInt)+3 end
  264.                     else Lgh:=0;
  265.                   end;
  266.                 deLong: begin
  267.                   Val(Value,li,ec);
  268.                   If (ec=0)
  269.                     then begin cLong:=li; Lgh:=SizeOf(cLong)+3 end
  270.                     else Lgh:=0;
  271.                   end;
  272.                 deDbl:  begin
  273.                   Val(Value,d,ec);
  274.                   If (ec=0)
  275.                     then begin bDbl:=d; Lgh:=SizeOf(bDbl)+3 end
  276.                     else Lgh:=0;
  277.                   end;
  278.                 deByte: begin
  279.                   Val(Value,li,ec);
  280.                   If (ec=0) and (li>=0) and (li<256)
  281.                     then begin cByte:=li; Lgh:=SizeOf(cByte)+3 end
  282.                     else Lgh:=0;
  283.                   end;
  284.                 deZStr: begin
  285.                   For b:=1 to length(Value) do czStr[b]:=Value[b];
  286.                   czStr[length(Value)+1]:=#0;
  287.                   Lgh:=length(Value)+1+1+2;
  288.                   end;
  289.                 else    Lgh:=0;
  290.                 end{cases};
  291.               i:=MaxInt;
  292.               end{did it}
  293.             else inc(i);
  294.           end{While};
  295.         end{extended};
  296.   End{With}; End;
  297.  
  298. {----- tBinaryDxfScanner Class object -----}
  299.  
  300. Constructor tBinaryDxfScanner.Create
  301.     (const Pathname: string; aClusterSize: word);
  302.   Begin
  303.     Inherited Create(Pathname,aClusterSize,SizeOf(tDxfBinaryDatum));
  304.   { Note that the SizeOf will give the maximum size of the record.}
  305.   End;
  306.  
  307. Function tBinaryDxfScanner.LocNextDxfRec
  308.     (var pRec: pDxfBinaryDatum; var GroupCode: integer): boolean;
  309.   Var NbrFound,LghRec: word;
  310.   Begin
  311.     If LocNextVarLghRec(pByteArray(pRec),NbrFound)
  312.       then begin
  313.         GetCodeAndLgh(pRec,GroupCode,LghRec);
  314.         If LghRec=0 then Result:=false
  315.         Else begin CurIndex:=PrevIndex+LghRec; Result:=true end;
  316.         end
  317.       else Result:=false;
  318.   End;
  319.  
  320. Constructor tBufferedFileWriter.Create
  321.     (const Pathname: string; aClusterSize: word);
  322. { creates a new file and opens it, overwriting any previous. }
  323.   Begin
  324.   Inherited Create;
  325.   Assign(Chan,Pathname); ReWrite(Chan,1{record size});
  326.   SizeOfBuf:=aClusterSize;
  327.   GetMem(PBuf,SizeOfBuf);
  328.   End;
  329.  
  330. Procedure tBufferedFileWriter.WriteRec (var Rec; NbrBytes: word);
  331. { writes the NbrBytes starting at Rec to the buffer.  When the
  332.   buffer is full it is copied to disk. }
  333.   Var i: word;
  334.   Begin
  335.   For i:=1 to NbrBytes do begin
  336.     pBuf^[oi]:=tByteArray(Rec)[i];
  337.     Inc(oi);
  338.     If oi=SizeOfBuf then FlushToDisk;
  339.     end;
  340.   End;
  341.  
  342. Procedure tBufferedFileWriter.FlushToDisk;
  343.   Begin
  344.   If oi>0
  345.     then BlockWrite(Chan,pBuf^,oi);
  346.   oi:=0;
  347.   End;
  348.  
  349. Destructor tBufferedFileWriter.Distroy;
  350. { copies the stuff, if any, in the buffer out to the file,
  351.   closes the file, and returns the buffer memory to system. }
  352.   Begin
  353.   If oi>0
  354.     then FlushToDisk;
  355.   Close(Chan);
  356.   If SizeOfBuf>0 then FreeMem(pBuf,SizeOfBuf);
  357.   End;
  358.  
  359. {=====} END. {=========================================================}
  360.  
  361.